home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / full-test.scm < prev    next >
Text File  |  1992-09-21  |  5KB  |  127 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: full-test.scm,v 1.2 1992/09/21 21:26:17 birkholz Exp $
  39.  
  40. (define (display-simple-condition condition)
  41.   (display (dylan-call dylan:condition-format-string condition))
  42.   (do ((args (dylan-call dylan:condition-format-arguments condition)
  43.          (cdr args)))
  44.       ((null? args))
  45.     (display " ") (write (car args))))
  46.  
  47. (define (display-condition condition)
  48.   (newline)
  49.   (let ((condition-type (get-type condition)))
  50.     (cond
  51.      ((eq? condition-type <simple-error>)
  52.       (display ";Error: ") (display-simple-condition condition))
  53.      ((eq? condition-type <simple-warning>)
  54.       (display ";Warning: ") (display-simple-condition condition))
  55.      ((eq? condition-type <type-error>)
  56.       (display ";Error: ")
  57.       (write (dylan-call dylan:type-error-value condition))
  58.       (display " is not an instance of ")
  59.       (display (class.debug-name
  60.         (dylan-call dylan:type-error-expected-type
  61.                 condition))))
  62.      (else
  63.       (display ";Unhandled dylan condition: ")
  64.       (write condition)))))
  65.  
  66. (define (make-expression preamble compiled-output)
  67.   `(BEGIN
  68.      ,@preamble
  69.      (LET* ((!MULTIPLE-VALUES (VECTOR '()))
  70.         (!RESULT ,compiled-output))
  71.        (IF (EQ? !RESULT !MULTIPLE-VALUES)
  72.        (LET RESULT-LOOP
  73.            ((COUNT 1)
  74.         (RESULTS (VECTOR-REF !MULTIPLE-VALUES 0)))
  75.          (IF (PAIR? RESULTS)
  76.          (LET ((RESULT (CAR RESULTS)))
  77.            (NEWLINE)
  78.            (DISPLAY ";Value[")(DISPLAY COUNT)(DISPLAY "]: ")
  79.            (WRITE RESULT)
  80.            (RESULT-LOOP (+ 1 COUNT) (CDR RESULTS)))
  81.          (NEWLINE)))
  82.        (BEGIN
  83.          (NEWLINE)(DISPLAY ";Value: ")(WRITE !RESULT)(NEWLINE))))))
  84.  
  85. (define (test file)
  86.   (with-input-from-file file
  87.     (lambda ()
  88.       (let loop ((module-variables '()))
  89.     (let ((sexpr (read)))
  90.       (if (eof-object? sexpr)
  91.           (begin
  92.         (newline)
  93.         (newline))
  94.           (begin
  95.         (pp sexpr)
  96.         (loop
  97.          ;; Return from here with new module-variables.
  98.          (call-with-current-continuation
  99.           (lambda (error-exit)
  100.             (dylan::catch-all-conditions
  101.              (lambda ()
  102.                (dylan::handler-bind
  103.             <condition>            ; type
  104.             (make-dylan-callable        ; function
  105.              (lambda (condition next-handler)
  106.                next-handler
  107.                (display-condition condition)
  108.                (newline)
  109.                (error-exit module-variables)))
  110.             (make-dylan-callable        ; test
  111.              (lambda (condition)
  112.                condition
  113.                #T))
  114.             (make-dylan-callable        ; description
  115.              (lambda (stream)
  116.                (display "error handler from full-test.scm"
  117.                     stream)))
  118.             (lambda ()
  119.               (compile-expression
  120.                sexpr '!MULTIPLE-VALUES module-variables
  121.                (lambda (new-vars preamble compiled-output)
  122.                  (implementation-specific:eval
  123.                   (make-expression preamble compiled-output))
  124.                  (append new-vars module-variables)))))))))))))))))
  125.  
  126. (define (test-dylan-examples) (test "dylan-examples.dyl"))
  127.